home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Tech Arsenal 1
/
Tech Arsenal (Arsenal Computer).ISO
/
tek-02
/
wedits22.zip
/
WWIVOUTP.PAS
< prev
Wrap
Pascal/Delphi Source File
|
1991-08-15
|
6KB
|
289 lines
UNIT WWIVOutp;
{$D-}
{{$DEFINE b1200}
INTERFACE
CONST
Black = 0;
Blue = 1;
Green = 2;
Cyan = 3;
Red = 4;
Magenta = 5;
Brown = 6;
LightGray = 7;
DarkGray = 8;
LightBlue = 9;
LightGreen = 10;
LightCyan = 11;
LightRed = 12;
LightMagenta = 13;
Yellow = 14;
White = 15;
Blink = 128;
C0 = ^C'0';
C1 = ^C'1';
C2 = ^C'2';
C3 = ^C'3';
C4 = ^C'4';
C5 = ^C'5';
C6 = ^C'6';
C7 = ^C'7';
PROCEDURE GotoXY(x,y:integer);
PROCEDURE ClrScr;
PROCEDURE ClrEol;
PROCEDURE TextColor(n:integer);
PROCEDURE TextBackground(n:integer);
PROCEDURE Print(s:string);
PROCEDURE Prompt(s:string);
FUNCTION WhereX : byte;
FUNCTION WhereY : byte;
IMPLEMENTATION
USES CRT, DOS;
TYPE
Translation = (None, Bios, DirectVideo, ANSI);
VAR
OldOutput : text;
Translate : Translation;
CenterString : string;
ESCString : string;
FUNCTION WhereX : byte;
BEGIN
WhereX:=Crt.WhereX;
END;
FUNCTION WhereY : byte;
BEGIN
WhereY:=Crt.WhereY;
END;
PROCEDURE Print(s:string);
BEGIN
writeln(s);
END;
PROCEDURE Prompt(s:string);
BEGIN
write(s);
END;
PROCEDURE TextColor;
BEGIN
Crt.Textcolor(n);
END;
PROCEDURE TextBackground;
BEGIN
Crt.textbackground(n);
END;
PROCEDURE GotoXY(x,y:integer);
BEGIN
Crt.gotoxy(x,y);
{$IFDEF b1200}
delay(8*12);
{$ENDIF}
{$IFDEF b2400}
delay(8*6);
{$ENDIF}
END;
PROCEDURE ClrScr;
BEGIN
{$IFDEF b1200}
delay(4*12);
{$ENDIF}
{$IFDEF b2400}
delay(4*6);
{$ENDIF}
Crt.ClrScr
END;
PROCEDURE ClrEol;
BEGIN
{$IFDEF b1200}
delay(4*12);
{$ENDIF}
{$IFDEF b2400}
delay(4*6);
{$ENDIF}
Crt.ClrEol
END;
PROCEDURE Color(f,b:byte);
BEGIN
TextColor(f);
TextBackground(b);
END;
PROCEDURE DoColor(ch:char);
BEGIN
{$IFDEF b1200}
delay(12);
{$ENDIF}
{$IFDEF b2400}
delay(6);
{$ENDIF}
CASE ch OF
'0' : Color(LightGray,Black);
'1' : Color(LightCyan,Black);
'2' : Color(Yellow,Black);
'3' : Color(Magenta,Black);
'4' : Color(White,Blue);
'5' : Color(Green,Black);
'6' : Color(Red+Blink,Black);
'7' : Color(LightBlue,Black);
ELSE Color(LightGray,Black);
END;
END;
PROCEDURE Center(VAR s:string);
VAR
i,l : integer;
BEGIN
l:=0;
FOR i:=1 TO length(s) DO
BEGIN
inc(l);
IF s[i]=^C THEN dec(l,2);
END;
FOR i:=1 TO 40-(l div 2) DO
write(OldOutput,' ');
WHILE s<>'' DO
IF s[1]<>^C THEN
BEGIN
write(OldOutput,s[1]);
delete(s,1,1);
END
ELSE BEGIN
DoColor(s[2]);
delete(s,1,2);
END;
END;
{$F+}
FUNCTION DoNothing(VAR f:TextRec):integer;
BEGIN
DoNothing :=0;
END;
FUNCTION TranslateOutput(VAR f:TextRec):integer;
VAR
i:integer;
ch : char;
p : integer;
x, y, e : integer;
BEGIN
WITH f DO
FOR i:=0 TO BufPos-1 DO
BEGIN
ch :=BufPtr^[i];
CASE UserData[1] OF
0 : BEGIN
IF Translate <> None THEN
BEGIN
IF ch=^C THEN
UserData[1]:=1
ELSE
IF ch=^L THEN
clrscr
ELSE IF ch=^B THEN
UserData[1]:=2
ELSE IF ch=^[ THEN
UserData[1]:=3
ELSE
BEGIN
{$IFDEF b1200}
delay(12);
{$ENDIF}
{$IFDEF b2400}
delay(6);
{$ENDIF}
write(OldOutput,ch);
END
END
ELSE BEGIN
write(OldOutput,ch);
{$IFDEF b1200}
delay(12);
{$ENDIF}
{$IFDEF b2400}
delay(6);
{$ENDIF}
END;
END;
1 : BEGIN
DoColor(ch);
UserData[1]:=0;
END;
2 : IF ch<>^M THEN
CenterString := CenterString + ch
ELSE BEGIN
Center(CenterString);
UserData[1]:=0;
write(OldOutput,^M);
CenterString := '';
END;
3 : BEGIN
ESCString:=EscString+ch;
IF ch IN ['A'..'Z','a'..'z'] THEN
BEGIN
UserData[1]:=0;
IF ESCString='[K' THEN ClrEol
ELSE IF ESCString='[2J' THEN ClrScr
ELSE IF ESCString='[7m' THEN Color(0,7)
ELSE IF ESCString='[87m' THEN Color(7,0)
ELSE IF ESCString='[47m' THEN TextBackground(7)
ELSE IF ESCString='[0;30m' THEN TextColor(0)
ELSE IF ch='D' THEN
BEGIN
Delete(EscString,1,1);
Delete(EscString,length(escstring),1);
Val(escstring,x,y);
gotoxy(wherex-x,wherey);
END
ELSE IF ch='H' THEN
BEGIN
p:=pos(';',EscString);
Val(copy(EscString,p+1,length(EscString)-p-1),x,e);
Val(copy(EscString,2,p-2),y,e);
gotoxy(x,y);
END;
EscString:='';
END
END;
END;
END;
f.BufPos:=0;
TranslateOutput:=0;
END;
{$F-}
BEGIN
IF Copy(GetEnv('BBS'),1,4)='WWIV' THEN Translate:=NONE
ELSE Translate:=DirectVideo;
TextRec(OldOutput) := TextRec(OutPut);
WITH TextRec(Output) DO
BEGIN
Mode:=fmOutput;
InOutFunc := @TranslateOutput;
FlushFunc := @TranslateOutput;
GetMem(BufPtr,128);
UserData[1]:=0;
END;
CenterString:='';
ESCString:='';
CheckSnow:=False;
END.